perm filename JUST.F4[NEW,LCS]1 blob sn#147677 filedate 1975-02-25 generic text, type T, neo UTF8
00100	C  TO JUSTIFY SEVERAL MSS FILES AT ONCE. (UP TO 15.)(8*15=120)
00110	C TO CONVERT(ONE FILE AT A TIME)TO NEW FORMAT, USE 'CONVT' AS 'LAST NAME'.
00200		COMMON/RQ/ RN(20000)/Q/PWDS(2500) ,RSTFAC(120),STFF(120),
00400		1 V(200),JR(120),P1,P2,I,M
00450	C  M=NUM OF STAVES. (BY 8S)
00500		COMMON JY,L,R8,R4,RDIS /RS/JW(120)
00550		
00700		TYPE 1
00800	1	FORMAT(' FILE NAME 1?  '$)
00900		ACCEPT 200,N1
01000	200	FORMAT(A5)
01100		TYPE 300
01200	300	FORMAT(' LAST NAME?  '$)
01300		ACCEPT 200,N2
01310		TYPE 3011
01320	3011	FORMAT(' TYPE OUTPUT NAME 1 -- '$)
01330		ACCEPT 200,NMX
01340		IF(N2.EQ.'CONVT')GO TO 111
01400		TYPE 100
01500	100	FORMAT(' POS.1, POS.2 -  '$)
01600		ACCEPT 111,P1,P2
01700	111	FORMAT(2F)
01800		IF(NMX.EQ.' ')NMX='AAAAA'
01900	
01910		JW(1)=1
01920		JR(1)=1
02000		M=1
02100		L=0
02200		JX=1
02300		IX=1
02400		NX=1
02500		NM=N1
02600	40	CALL IFILE(1,NM)
02700		READ (1)J,I,
02800		1 (PWDS(K),K=JX,JX+J),(RN(K),K=IX,I+IX-2),ISCR,(V(K),K=1,ISCR),
02900		1 ISCR,(V(K),K=1,ISCR),(RSTFAC(K),K=NX,NX+7),(STFF(K),K=
03000		1 NX,NX+7),K
03100	
03200		IF(N2.EQ.'CONVT')GO TO 2
03210	C ********* TYPE 999 AS POS1. FOR 'CONVERT', NAME2 WILL BE OUTPUT NM.
03300		RX=NX-1
03500	
03560		IF(RX.EQ.0)GO TO 410
03600		DO 41 K=JX,JX+J
03700		PWDS(K)=PWDS(K)+L
03800		KX=PWDS(K)+2
03820	C  +2 IS FOR STAFF #
03840	41	RN(KX)=RN(KX)+RX
03900	410	IX=I+IX-1
03910		L=IX-1
04000		JX=J+JX
04010		JW(M+1)=JX
04020	C  POINTER TO START OF PWDS FOR EACH FILE
04030		JR(M+1)=IX  
04100		NX=NX+8
04200		IF(IX.LT.19500)GO TO 400
04300		RRT=IX
04400		TYPE 111,RRT
04500	400	IF(NM.EQ.N2)GO TO 5
04600		NM=NM+2
04700		M=M+1
04800		GO TO 40
04900	
05700	2	JJ=1
05800	3001	L=PWDS(JJ)
05900		K=L+1
06000		A=RN(K)
06010		Z=RN(L)
06100		IF(A.LT.5)GO TO 3002
06200		IF(A.LE.10)GO TO 1177
06250		IF(A.NE.20)GO TO 3002
06300	1177	IF(A.NE.6)GO TO 3003
06400		RN(K)=9
06500		GO TO 3002
06600	3003	IF(A.NE.5)GO TO 3004
06700		RN(K)=10
06800		IF(Z.LT.4)GO TO 3010
07000		CALL EXCH(RN(L+5),RN(L+6))
07200		GO TO 3002
07300	3004	IF(A.NE.7)GO TO 3005
07400		RN(K)=17
07500		GO TO 3010
07600	3005	IF(A.EQ.8)RN(K)=5
07700		IF(A.EQ.9)RN(K)=6
07800		IF(A.NE.10)GO TO 3006
07900		RN(K)=8
07910		IF(Z.LT.4)GO TO 3010
07920		CALL EXCH(RN(L+4),RN(L+5))
07930		CALL EXCH(RN(L+6),RN(L+5))
08000	 	GO TO 3002
08100	3006	IF(A.EQ.20)RN(K)=7
08200		IF(A.NE.18)GO TO 3002
08300	3010	FORMAT(' ITEM ',I3,', CODE ',F3.0)
08400		TYPE 3010,JJ,A
08410	3002	A=RN(L+2)
08420		RN(L+2)=RN(L+3)
08430		RN(L+3)=A
08500		A=L+Z+3
08600		JJ=JJ+1
08700		IF(A.EQ.PWDS(JJ))GO TO 3001
10000		MX=1
10100	CC	IF(N2.NE.' ')NM=N2
10200		GO TO 6
10300	
10400	5	I=JX-1
10500	C  TOTAL IN RN ('I' IN MXX.F4)
10600		CALL JJUST
10700	
10800	C  START OF WRITER
10810	6	NM=NMX
10900		JX=1
11000		IX=1
11100		NX=1
11300		L=0
11400	
11600		MX=M
11700		M=1
11800	7	CALL OFILE(21,NM)
11900		IF(N2.EQ.'CONVT')GO TO 3
12000		J=JW(M+1)-JW(M)
12100		I=JR(M+1)-JR(M)+1
12200		P1=PWDS(JX+J)
12300		RX=NX-1
12350		IF(RX.EQ.0)GO TO 3
12400		DO 61 K=JX,JX+J-1
12500		KX=PWDS(K)
12600		PWDS(K)=KX-L
12700		KX=KX+2
12800	61	RN(KX)=RN(KX)-RX
12850		PWDS(JX+J)=PWDS(JX+J)-L
12900	3	L=I+IX-2
13000		WRITE(21)J,I,
13100		1 (PWDS(K),K=JX,JX+J),(RN(K),K=IX,L),ISCR,(V(K),K=1,ISCR),
13200		1 ISCR,(V(K),K=1,ISCR),(RSTFAC(K),K=NX,NX+7),(STFF(K),K=
13300		1 NX,NX+7),K,K
13400		PWDS(JX+J)=P1
13500		TYPE 60,NM
13600	
13700		IF(M.EQ.MX)CALL EXIT
13800		M=M+1
13900		JX=JW(M)
14000		IX=JR(M)
14100	
14200		NX=NX+8
14300		END FILE 21
14400		NM=NM+2
14500		GO TO 7
14600	60	FORMAT(1XA5)
14700		END
14800	
14900		SUBROUTINE JJUST
15000		DATA RSP/.5/,RI/4.5/,RPX/.2/
15100		COMMON JY,L,R8,R4,RDIS
15200		COMMON/RQ/ RN(20000)/Q/PWDS(2500) 
15300		1,RSTFAC(120),STFF(120),R(2,100),JR(120),P1,P2,I,M
15400	
15500		DIMENSION IR(2,100)
15600		EQUIVALENCE (R,IR)
15800		IX=PWDS(I+1)-1
15900		PRCNT=1.
16100		RRT=P2
16200		RZRO=P1
16300		R4=P1
16400		IF(RRT.EQ.0)RRT=200
16500		IF(RZRO.EQ.0)RZRO=.001
16600		JCNT=0
16700		RJSZ=RI
16800	CC	R6=0
16900		ML=1
17000		ROV=RRT
17100	19	IF(JCNT.GT.9)GO TO 101
17110		RP=PRCNT
17200		RJSZ=RJSZ-RPX	
17300		JCNT=JCNT+1
17400	C  TEMPORARY COUNTER
17500		TYPE 111,JCNT
17600	111	FORMAT(I4)
17700	
17800		DO 11 KN=-3,M*8-4
17900		RSPC=0
18000	CC	MQ=MOD(KN,8)
18100	CC	IF(MQ.EQ.0)MQ=8
18200	CC	MQ=MQ-4
18300	CC	R8=MQ
18400		R8=KN
18500		N=0
18600	
18700		DO 2 K=1,I
18800		L=PWDS(K)
18900		RA=RN(L+1)
19000		RB=RN(L+3)
19200		IF(RB.LT.RZRO)GO TO 2
19210		IF(RN(L+2).EQ.R8)GO TO 77
19220		IF(RA.NE.4)GO TO 2
19230	C  SKIPS HOMED NOTES (IN CHORDS)
19240	77	IF(RA.EQ.1)GO TO 10
19250	27	IF(RA.LE.4)GO TO 177
19260		IF(RA.LT.17)GO TO 2
19270	C  LOOKS AT NOTES,RESTS,CLEFS,BAR LINES,KSIGS,METERS.
19280	177	IF(RA.NE.4)GO TO 10
19290		IF(RN(L).GT.2)GO TO 2
19600	C  SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
19700	10	N=N+1
19800		R(1,N)=RB
19900		IR(2,N)=L
20000		IF(N.EQ.100)GO TO 28
20100	C  ONLY TREATS 100 ITEMS AT A TIME.
20200	
20300	
20400	2	CONTINUE
20500	
20600		IF(N.EQ.0)GO TO 11
20700	CC28	KM=JFAC(L)
20800	C  SEE FUNCTION JFAC.  RSTFAC PNTR.
20900	28	DO 23 K=1,N
21000	23	IF(RN(IR(2,K)+1).NE.4)GO TO 24
21100	C  SKIPS IF ONLY BAR LINES ON THIS STAFF
21200		GO TO 11
21300	24	RSTJC=RSTFAC(KN+4)*PRCNT
21400		CALL SORT2(R,N)
21500	
21600	C  JUMP IF LAST IS A BAR LINE.
21700		K=0
21800		JLDGR=0
21900	     	JX=0
22000	22	K=K+1
22100	122	L=IR(2,K)
22200		RA=RN(L+1)
22300		RB=0
22400		RX=RN(L+5)
22410	C  RX=PARAM 5
22455		RX6=RN(L+6)
22500		RY=1
22600		RW=AMOD(RN(L+4),100.)
22700		IF(RA.GT.1)GO TO 4
22800		RZ=RN(L+7)
22900		IF(LDGR.NE.JLDGR)JLDGR=0
23000		LDGR=0
23100		JY=K
23200		DO 32 JJ=JY+1,N+1
23300		K=JJ
23400	32	IF(R(1,JJ)-R(1,JJ-1).GT.RSP)GO TO 35
23500	C  FOUND HOW MANY MEMBERS TO CHORD.
23600	35	RB=0
23700		K=K-1
23800		RQ=0
23900		RD=0
24000	125	IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
24100		DO 37 JJ=JY,K-1
24200		IF(RD.NE.0)GO TO 38
24300	C FINDS ONLY HIGH OR! LOW LED. LINE.
24400		JIR=IR(2,JJ)
24500		RW=AMOD(RN(JIR+4),100.)
24600		IF(RW.GT.11)GO TO 277
24610		IF(RW.GE.2)GO TO 38
24620	277	LDGR=-1
24800		IF(RW.GT.11)LDGR=1
24900		IF(JLDGR.EQ.LDGR)GO TO 36
25000		JLDGR=LDGR
25100	C LDGR IS FOR LEDGER LINES.
25200		GO TO 38
25300	36	RD=1.5
25400		RQ=RD
25500	38	IF(RB.GT.2)GO TO 222
25600	C  JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
25700		RZZ=RN(JIR+7)
25800		RE=RN(JIR+5)
26210		IF(RB.GE.2)GO TO 477
26220		IF(RZZ.GE.10)GO TO 377
26230		IF(RE.GE.20)GO TO 477
26240		IF(AMOD(RZZ,10.).EQ.0)GO TO 477
26250	377	RB=1.5+EXTEN(RZZ)
26260	C  SPACE FOR DOT OR TAIL(IF STEM UP)
26270	477	IF(ABS(RN(JR+6)).EQ.10)RB=RB+2
26300	C  FOR CHORD TONES ON RIGHT OF STEM UP.
26400	C  LOOKS THROUGH ALL NOTES OF A CHORD.
26500	222	IF(AMOD(RE,10.).EQ.0)GO TO 37 
26600	C  JUMP IF NO ACCIS.
26700	425	RD=2*RY+EXTEN(RE)
26800		IF(RQ.GT.RD)RD=RQ
26900		RQ=RD
27000	C  FUNCT. EXTEN=AMOD(X,1.)*10.
27100	37 	CONTINUE
27200		IF(RY.NE.1)RB=RB-.5*RJSZ
27300	C  MINI NOTES NEED LESS SPACE
27400	25	IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSTJC
27500		GO TO 17
27600	4	IF(RA.NE.3)GO TO 29
27700		RB=3
27800		IF(RX.GT.100)RB=1.5
27900	C  CHECK ON SIZE NEEDED FOR CLEFS
28000	29	IF(RA.NE.4)GO TO 26
28100		RB=-RJSZ/2
28200		RD=.9
28300		GO TO 25
28400	26	IF(RA.NE.18)GO TO 30
28500		IF(RX6.GT.9)GO TO 31
28510		IF(RX.GT.9)GO TO 31
28600	C  CHECKS FOR 2-DIGIT METERS
28700		RB=-1
28800		RD=1
28900		GO TO 25
29000	31	RB=2
29100		RD=3
29200		GO TO 25
29300	30	IF(RA.NE.17)GO TO 17
29500		RB=2*(ABS(RX)-1)-2
29600		RD=2
29700		GO TO 25
29800	C  SPACES FOR CORRECT NUM OF ACCIS.
29900	17	RC=(RB+RJSZ)*RSTJC
30000	C  RJSZ=DEFAULT SIZE
30100		JX=JX+1
30200		R(2,JX)=RC
30300		R(1,JX)=R(1,K)
30400	3	IF(K.LT.N)GO TO 22
30500		RA=R(1,1)
30600		RB=R(2,1)
30700	
30800		DO 13 KX=2,JX
30900		RE=R(1,KX)
31000	C  POS. BEFORE SHIFTING
31100		IF(ABS(RE-RA).GT..5)GO TO 14
31200		IF(R(2,KX).GT.RB)GO TO 16
31300	C  SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
31400		GO TO 13
31500	CC	IF(RZZ.LE.RB)GO TO 13
31600	C  JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
31700	CC	RB=RZZ-RB
31800	14	RD=RA+RB-RE
31900		IF(RD.LE.0)GO TO 16
32000	C  THERE'S ENOUGH ROOM
32100	CC	RD=RA+RB-RE+RD
32200		R4=RE+RSPC-.001
32300		R5=1000
32400	C  MAYBE MORE? ↑↑↑↑↑
32500		R8=RD
32600		R9=0
32700		RSPC=RSPC+RD
32800	C  RSPC SAVES TOTAL SPACE ADDED
32900	C  GO EXPAND IT
33000		IF(R(2,KX).NE.0)GO TO 66
33100	16	RB=R(2,KX)
33200	13	RA=RE
33300	11	CONTINUE
33400	110	IF(ROV.LE.RRT+.01)GO TO 18
33500		IF(RJSZ.GT.4)RJSZ=4
33600		PRCNT=(ROV-RZRO)/(RRT-RZRO)
34000		IF(PRCNT.NE.RP)GO TO 19
34100		R4=RZRO
34200		R5=ROV
34300		R8=RZRO
34400		R9=RRT-.001
34500	C  JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
34600		ML=2
34700		GO TO 66
34800	18	ML=3
34900		R8=RRT-ROV
35000		R9=0
35100	C  GOES BACK TO PICK UP DANGLING ITEMS(BEYOND RRT)
35200		R4=RRT+.001
35300	CC	R5=ROV+2
35400		R5=ROV+100
35600	66	JY=1
35900		L=JY
36000		IF(R9.NE.0)RDIS=(R9-R8)/(R5-R4)
36100	
36200	6551	RB=RN(JY)
36400	C  IF STAFF#>4, ALL STAVES ARE MOVED.
36500		RA=RN(JY+1)
36600	C SKIPS IF NOT SPECIAL CODE NUM.
36700		RN3=RN(JY+3)
36800		IF(RN3.GT.R5)GO TO 7551
36900		RC=-1
37000		RD=0
37710		IF(RA.LT.5)GO TO 677
37716		IF(RA.LE.7)RD=-1
37722	677	IF(RA.EQ.4.)GO TO 777
37728		IF(RD)GO TO 777
37734		IF(RN(JY+5).NE.50)GO TO 877
37740	777	RC=0
37746	C RC=0 FOR CODES 4,5,6
37752	877	RN6=RN(JY+6)
37758		IF(RN3.GE.R4)GO TO 9551
37764	      IF(RC)GO TO 7551
37770		IF(RC.NE.0)GO TO 9551
37776		IF(RN6.LE.R4)GO TO 7551
37782		IF(RN6.GE.R5)GO TO 7551
37790	C RIGHT SIDE IS BEFORE OR AFTER MOVE AREA.
37900	C   (50=CRESC., DECRESC.)
37910	9551	IF(RA.EQ.8)GO TO 7552
37955	C 8=STAFF. ONLY MOVES OR COPIES TO NEW STAFF NUM. OTHER PARAMS UNAFFECTED.
38000		RQ6=RN6-R5
38100		RX=0
38200		RV=0
38300		IF(RA.NE.6)GO TO 21
38310		IF(RB.LT.7)GO TO 21
38400		RX=RN(L+9)
38500		RY=RX-R5
38600		RZ=R4-RX
38700		IF(RN(L+10).LT.30)GO TO 221
38800		RW=RN(L+8)
38900		IF(RW.LT.R4)GO TO 221
38910		IF(RW.LE.R5)RV=-1
39000	221	IF(RY.GE.0)GO TO 21
39010		IF(RZ)RX=-1
39100	C PARTIAL BEAM IS WITHIN MOVE AREA.
39200	21	IF(R9.EQ.0)GO TO 2551
39300		IF(RN3.GE.R4)CALL MVBX(3)
39400		IF(RC)GO TO 7552
39600		IF(RA.NE.4.)GO TO 772
39610		IF(RB.LT.4)GO TO 7552
39620	772	IF(RQ6)CALL MVBX(6)
39700	C  END POINT OUTSIDE OF MOVE RANGE NOT AFFECTED.
39800		IF(RA.NE.6)GO TO 7552
39900		IF(RX)CALL MVBX(9)
40000		IF(RV)CALL MVBX(8)
40100	C  ONLY TRUE WHEN RA=9
40200		GO TO 7552
40300	
40400	2551	IF(RN3.GE.R4)RN3=RN3+R8
40500		RN(L+3)=RN3
40700	      IF(RQ6.GE.0)GO TO 773
40710		IF(RD)GO TO 774
40720		IF(RA.NE.4)GO TO 773
40730		IF(RB.LE.3.)GO TO 773
40740	774	RN(L+6)=RN(JY+6)+R8
40750	773	IF(RX)CALL MVBEAM(9)
40800		IF(RV)CALL MVBEAM(8)
40900		IF(RN3.GT.ROV)ROV=RN3
41000	C ??? NOT YET FIXED FOR ENDS OF SLURS OR LINES
41100	7552	L=RB+3+L
41200	7551	JY=RB+3+JY
41300		L=JY
41400		IF(JY.LT.IX)GO TO 6551
41500		GO TO (16,18,101),ML
41600	C ↑↑↑↑↑↑????
41800	101	END
41900		
42000	C  THESE MOVE ENDS OF PARTIAL INNER BEAMS.
42100		SUBROUTINE MVBEAM(I)
42200	C  L AND JY ARE FOR MOVES TO DIFF. STAFF.
42300		COMMON JY,L,R8,R4,RDIS /RQ/RN(20000)
42400		Y=RN(JY+I)
42500		Z=ABS(Y)
42600		IF(Z.LT.100.)GO TO 1
42700	C  NEXT FOR MINIS, DIAMONDS, 'X' NOTES. (LIMIT OF +-99 ON ALTITUDE.)
42800		Y=AMOD(Y,100.)
42900		X=Y+R8
43000		Z=Z-ABS(Y)+ABS(X)
43100	C  PUTS ALL INTO POSITIVE
43200		IF(X)Z=-Z
43300		GO TO 2
43400	1	Z=Y+R8
43500	2	RN(L+I)=Z
43600		END
43700	
43800		SUBROUTINE MVBX(I)
43900		COMMON JY,L,R8,R4,RDIS /RQ/RN(20000)
44100		RN(L+I)=R8+(RN(JY+I)-R4)*RDIS
44200		END
44300	
44400		SUBROUTINE EXCH(X,Y)
44500		Z=X
44600		X=Y
44700		Y=Z
44800		END
44900		SUBROUTINE SORT2(RPOS,M)
45000		DIMENSION RPOS(2,1000)
45100		L=2
45200	3	J=-1
45300		RX=RPOS(1,L-1)
45400		DO 2 K=L,M
45500		IF(RPOS(1,K).GE.RX)GO TO 2
45600		RX=RPOS(1,K)
45700	C   WHY WERE ALL THE RX'S  JX ????? 9/6/73
45800		J=K
45900	2	CONTINUE
46000		IF(J)GO TO 4
46100		K=L-1
46200		CALL EXCH(RPOS(1,K),RPOS(1,J))
46300		CALL EXCH(RPOS(2,K),RPOS(2,J))
46400	4	L=L+1
46500		IF(L.LE.M)GO TO 3
46600		END
46700	
46800		FUNCTION EXTEN(X)
46900		EXTEN=AMOD(X,1.)*10.
47000		END
47100	
47200	CC	FUNCTION JFAC(L)
47300	C  FINDS RSTFAC POINTER
47500	CC	COMMON/RQ/ RN(20000)/Q/PWDS(2500) 
47600	CC	1,RSTFAC(120),STFF(120),R(2,100),JR(120),P1,P2,I,M
47700	CC	K=0
47800	CC1	K=K+1
47900	CC	IF(L.GE.JR(K))GO TO 1
48000	CC	JFAC=K-2
48100	CC	END